/* Gyroe 1.0.0 */
/* fe_parser.c : Process statements, calling emit when
   necessary. Calls scanner to get tokens. */

#include <stdio.h>
#include <stdlib.h>
#include "fe_shared.h"
#include "fe_parser.h"

static void enter_toplevel()
/* Exiting a user-defined routine or type.
   Switch a few markers around so code generation targets
   toplevelsub. */
{
    /* Set [0] to the length. */
    code_area[code_area_pos][0] = seg_pos-1;

    currentsub = toplevelsub;
    code_area_pos = 0;
    seg_pos = tls_pos; seg_extra = tls_extra;
    previous_op = -1;
}

static void leave_toplevel()
/* Entering a user-defined routine or type.
   Switch the markers around to target a new entry,
   and also malloc space in that new entry. */
{
    int i;

    tls_pos = seg_pos; tls_extra = seg_extra;
    code_area_pos = save_code_area_pos;

    code_area_extra--; code_area_pos++;
    if (code_area_extra == -1) {
        code_area = (int **)realloc(code_area, (code_area_pos+64) * sizeof(int *));
        code_area_extra = 63;
    }

    code_area[code_area_pos] = malloc(128 * sizeof(int));

    seg_extra = 127; seg_pos = 0;
    /* The [0] entry will be used for length. */

    for (i = 1;i < 127;i++)
        code_area[code_area_pos][i] = -2;

    last_line_number = -1;
    previous_op = -1;
    save_code_area_pos = code_area_pos;
}

void init_parser()
{
    int i;

    /* Setup toplevelsub's block. */

    seg_pos = 0;
    seg_extra = 127;

    tls_pos = 0;
    tls_extra = 127;

    code_area = malloc(32 * sizeof(int *));
    code_area_extra = 31; code_area_pos = 0;

    code_area[0] = malloc(128 * sizeof(int));

    toplevelsub = 98;

    current_sequence = malloc(32 * sizeof(int));
    current_sequence_extra = 32; current_sequence_pos = -1;

    branch_list = malloc(32 * sizeof (int));
    branch_list_extra = 32; branch_list_pos = -1;

    init_stack = malloc(32 * sizeof (int));
    init_stack_extra = 32; init_stack_pos = -1;

    e_list = malloc(32 * sizeof (int));
    e_list_extra = 31; e_list_pos = 0;

    exit_list = malloc(32 * sizeof (int));
    exit_list_extra = 31; exit_list_pos = 0;

    backed_tok = 0;
    factors = 0;
    last_branch = -1;
    last_line_number = -1;
    loop_nest = 0;
    lhs_ptr = 0;
    lhs_subs_level = -1;
    OpWarning_called = 0;
    sample_size = 0;
    save_code_area_pos = 0;
    short_circuit = 0;
    short_circuit_B = 0;
    stmt_nest = 0;
    temps_allocated = 0;

    /* Just for now... */
    currentsub = toplevelsub;
    code_area_pos = 0;
    previous_op = -1;

    for (i = 1;i < 127;i++)
        code_area[code_area_pos][i] = -2;
}

static void not_reached(int word, char *statement)
{
    if (word != END && word != ELSE && word != ELSIF) {
        sprintf(fe_buffer, "Warning - %s:%d - statement after %s will never be executed.\n",
                name_ext(user_files[current_file_no]), line_number, statement);
        add_warning(fe_buffer);
    }
}

void init_check(int sym, int ref)
{
    int initlevel, mode, scope;

    initlevel = symtab[sym][S_INITLEVEL];
    mode = symtab[sym][S_MODE];
    scope = symtab[sym][S_SCOPE];

    if (initlevel == -1 && mode == M_NORMAL && scope != SC_LOOP_VAR && scope != SC_GLOOP_VAR) {
        if (scope != SC_PRIVATE && symtab[sym][S_OBJ] == NOVALUE ||
            scope == SC_PRIVATE && symtab[sym][S_VARNUM] >= symtab[currentsub][S_NUM_ARGS]) {
            if (ref) {
                if (scope == SC_GLOBAL || scope == SC_LOCAL)
                    emit_m1(GLOBAL_INIT_CHECK);
                else
                    emit_m1(PRIVATE_INIT_CHECK);
                emit(sym);
            }
            if (short_circuit <= 0 || !short_circuit_B) {

                init_stack_extra--; init_stack_pos++;
                if (init_stack_extra == -1) {
                    init_stack = (int *)realloc(init_stack, (init_stack_pos+8) * sizeof(int));
                    init_stack_extra = 7;
                }

                init_stack[init_stack_pos] = sym;
                symtab[sym][S_INITLEVEL] = stmt_nest;
            }
        }
    }
}

static void init_delete()
{
    int i, j;

    i = init_stack_pos;
    j = 0;

    while (j < i) {
        if (symtab[init_stack[j]][S_INITLEVEL] > stmt_nest)
            symtab[init_stack[j]][S_INITLEVEL] = -1;
        else
            break;
        j++;
    }

    if (j)
        /* Shift the used bits back to extra space. */
        init_stack_extra += j; init_stack_pos -= j;
}

static void emit_forward_addr()
{
    emit(0);

    if (seg_pos != last_branch) {
        branch_list_extra--; branch_list_pos++;
        if (branch_list_extra == -1) {
            branch_list = (int *)realloc(branch_list, (branch_list_pos+32) * sizeof(int));
            branch_list_extra = 31;
        }
        branch_list[branch_list_pos] = seg_pos;
        last_branch = seg_pos;
    }
}

static void straighten_branches()
{
    int br, i, target;

    for (i = branch_list_pos;i >= 0;i--) {
        target = code_area[code_area_pos][branch_list[i]];
        if (target <= seg_pos) {
            br = code_area[code_area_pos][target];
            if (br == ELSE || br == ENDWHILE || br == EXIT)
                BACKPATCH(branch_list[i], code_area[code_area_pos][target + 1]);
        }

        branch_list_extra++; branch_list_pos--;
    }
}

static void appendElist(int addr)
{
    e_list_extra--; e_list_pos++;
    if (e_list_extra == -1) {
        e_list = (int *)realloc(e_list, (e_list_pos+32) * sizeof (int));
        e_list_extra = 31;
    }

    e_list[e_list_pos] = addr;
}

static void appendXlist(int addr)
{
    exit_list_extra--; exit_list_pos++;
    if (exit_list_extra == -1) {
        exit_list = (int *)realloc(exit_list, (exit_list_pos+32) * sizeof (int));
        exit_list_extra = 31;
    }

    exit_list[exit_list_pos] = addr;
}

static void patchElist(int base)
{
    int e_list_top;

    while (e_list_pos > base) {
        BACKPATCH(e_list[e_list_pos], seg_pos + 1);
        e_list_extra++; e_list_pos--;
    }
}

static void patchXlist(int base)
{
    int exit_list_top;

    while (exit_list_pos > base) {
        BACKPATCH(exit_list[exit_list_pos], seg_pos + 1);
        exit_list_extra++; exit_list_pos--;
    }
}

static int expr_list()
{
    int n;

    BACKUP_NEXT_TOKEN

    if (token_name == RIGHT_BRACE)
        return 0;
    else {
        n = 0;
        short_circuit--;

        while (1) {
            expr();

            n++;
            NEXT_TOKEN

            if (token_name != COMMA)
                break;
        }
        short_circuit++;
    }

    BACKUP_TOK
    return n;
}


char * token_from_id(int token)
{
    int i;

    struct {
        int t_val;
        char *t_return;
    } lex_array[] = {
    {AND, "'and'"},
    {ATOM, "a number"},
    {BANG, "'!'"},
    {BY, "'by'"},
    {COLON, "':'"},
    {COMMA, "','"},
    {CONCAT, "'&'"},
    {CONSTANT, "'constant'"},
    {DIVIDE, "'/'"},
    {DIVIDE_EQUALS, "'/='"},
    {DO, "'do'"},
    {DOLLAR, "'$'"},
    {ELSE, "'else'"},
    {ELSIF, "'elsif'"},
    {END, "'end'"},
    {END_OF_FILE, "the end of file"},
    {EQUALS, "'='"},
    {EXIT, "'exit'"},
    {FOR, "'for'"},
    {FUNC, "a function"},
    {FUNCTION, "'function'"},
    {GLOBAL, "'global'"},
    {GREATER, "'>'"},
    {GREATEREQ, "'>='"},
    {IF,  "'if'"},
    {ILLEGAL_CHAR, "an illegal character"},
    {INCLUDE, "'include'"},
    {LEFT_BRACE, "'{'"},
    {LEFT_ROUND, "'('"},
    {LEFT_SQUARE, "'['"},
    {LESS, "'<'"},
    {LESSEQ, "'<='"},
    {MINUS, "'-'"},
    {MINUS_EQUALS, "'-='"},
    {MULTIPLY, "'*'"},
    {MULTIPLY_EQUALS, "'*='"},
    {NAMESPACE, "a namespace qualifier"},
    {NEWLINE, "end-of-line"},
    {NOT, "'not'"},
    {NOTEQ, "'!='"},
    {OR, "'or'"},
    {PLUS, "'+'"},
    {PLUS_EQUALS, "'+='"},
    {PROC, "a procedure"},
    {PROCEDURE, "'procedure'"},
    {QUESTION_MARK, "'?'"},
    {RIGHT_BRACE, "'}'"},
    {RIGHT_ROUND, "')'"},
    {RIGHT_SQUARE, "']'"},
    {RETURN, "'return'"},
    {SLICE, "a slice"},
    {STRING, "a character string"},
    {TO, "'to'"},
    {THEN, "'then'"},
    {TYPE, "a type"},
    {TYPE_DECL, "'type'"},
    {VARIABLE, "a variable"},
    {WITH, "'with'"},
    {WITHOUT, "'without'"},
    {WHILE, "'while'"},
    {XOR, "'xor'"}
    };

    for (i = 0;i <= 61;i++) {
        if (token == lex_array[i].t_val)
            return lex_array[i].t_return;
    }

    fprintf(stderr, "token '%d' didn't match anything.\n", token);
    return "...";
}

static void tok_match(int tok)
{
    NEXT_TOKEN

    if (token_name != tok) {
        sprintf(fe_buffer, "Syntax error - Expected to see possibly %s not %s.\n",
                token_from_id(tok), token_from_id(token_name));
        compile_error(fe_buffer);
    }
}

int undefined_var(int sym)
{
    int scope;

    scope = symtab[sym][S_SCOPE];

    if (scope == SC_UNDEFINED) {
        /* %s has not been declared */
        sprintf(fe_buffer, "%s has not been declared.", name_area[symtab[sym][S_NAME]]);
        compile_error(fe_buffer);
    }
    else if (scope == SC_MULTIPLY_DEFINED) {
        int i;

        fprintf(stderr, "Multiple definition error : %s is globally defined "
                        "in\n", name_area[symtab[sym][S_NAME]]);
        for (i = 0;i < dup_globals_last;i++)
            fprintf(stderr, "    %s\n", user_files[symtab[sym][S_FILE_NO]]);

        compile_error("");
    }
}

static void wrong_num_args(int sym)
{
    int args;

    args = symtab[sym][S_NUM_ARGS];

    if (!args)
        sprintf(fe_buffer, "%s takes no arguments.\n", name_area[symtab[sym][S_NAME]]);
    else if (args == 1)
        sprintf(fe_buffer, "%s takes only 1 argument.\n", name_area[symtab[sym][S_NAME]]);
    else
        sprintf(fe_buffer, "%s takes %d arguments.\n", name_area[symtab[sym][S_NAME]], args);

    compile_error(fe_buffer);
}

static void parse_args(int sym)
{
    int args, i;

    args = symtab[sym][S_NUM_ARGS];
    short_circuit--;

    for (i = 1;i <= args;i++) {
        expr();
        if (i != args) {
            NEXT_TOKEN

            if (token_name != COMMA) {
                if (token_name == RIGHT_ROUND)
                    wrong_num_args(sym);
                else {
                    BACKUP_TOK
                    tok_match(COMMA);
                }
            }
        }
    }

    NEXT_TOKEN
    short_circuit++;

    if (token_name != RIGHT_ROUND) {
        if (token_name == COMMA)
            wrong_num_args(sym);
        else {
            BACKUP_TOK
            tok_match(RIGHT_ROUND);
        }
    }
}

static void Factor()
{
    int n, save_factors, save_lhs_subs_level, sym;

    factors++;
    NEXT_TOKEN

    switch(token_name) {
        case VARIABLE:
            sym = token_sym;
            undefined_var(sym);

            if (OpWarning) {
                if (symtab[sym][S_USAGE] == U_VAR_UNUSED)
                    symtab[sym][S_USAGE] = U_VAR_READ;
                else if (symtab[sym][S_USAGE] == U_VAR_READ)
                    symtab[sym][S_USAGE] = U_VAR_RW;
            }

            init_check(sym, 1);
            emit_opnd(sym);

            if (sym == left_sym)
               lhs_subs_level = 0; /* start counting subscripts */

            short_circuit--;
            NEXT_TOKEN

            current_sequence_extra--; current_sequence_pos++;
            if (current_sequence_extra == -1) {
                current_sequence = (int *)realloc(current_sequence, 
                                   (current_sequence_pos+32) * sizeof(int));
                current_sequence_extra = 31;
            }
            current_sequence[current_sequence_pos] = sym;    

            while (token_name == LEFT_SQUARE) {
                if (lhs_subs_level >= 0)
                    lhs_subs_level++;

                save_factors = factors;
                save_lhs_subs_level = lhs_subs_level;
                expr();
                NEXT_TOKEN

                if (token_name == SLICE) {
                    expr();
                    emit_rhs_slice();
                    tok_match(RIGHT_SQUARE);
                    NEXT_TOKEN
                    break;
                }
                else {
                    BACKUP_TOK
                    tok_match(RIGHT_SQUARE);
                    current_sequence_extra++; current_sequence_pos--;
                    emit_rhs_subs(); /* current_sequence will be updated */
                }
                factors = save_factors;
                lhs_subs_level = save_lhs_subs_level;
                NEXT_TOKEN
            }
            current_sequence_extra++; current_sequence_pos--;
            BACKUP_TOK
            short_circuit++;
            break;
        case DOLLAR:
            if (current_sequence_pos != -1)
                emit_dollar();
            else
                compile_error("'$' must only appear between '[' and ']'.\n");
            break;
        case ATOM:
        case STRING:
            emit_opnd(token_sym);
            break;
        case LEFT_BRACE:
            n = expr_list();
            tok_match(RIGHT_BRACE);
            op_info1 = n;
            emit_right_brace_n();
            break;
        case LEFT_ROUND:
            expr();
            tok_match(RIGHT_ROUND);
            break;
        case FUNC:
        case TYPE:
            sym = token_sym; /* tok_match will change it. */
            tok_match(LEFT_ROUND);
            parse_args(sym);

            /* Predefined items go through emit_op. */
            if (symtab[sym][S_SCOPE] == SC_PREDEF)
                emit_op(symtab[sym][S_OPCODE]);
            else {
                symtab[sym][S_USAGE] = U_RT_CALLED;
                op_info1 = sym;
                emit_proc();
                if (OpTrace)
                    emit(UPDATE_GLOBALS);
            }
            break;
        default:
            sprintf(fe_buffer, "Syntax error - Expected to see an expression, "
                               "not %s\n", token_from_id(token_name));
            compile_error(fe_buffer);
            break;
    }
}

static void UFactor()
{
    NEXT_TOKEN

    switch (token_name) {
        case NOT:
            Factor();
            cont11ii(NOT, 1);
            previous_op = NOT;
            break;
        case MINUS:
            Factor();
            emit_uminus();
            break;
        case PLUS:
            Factor();
            break;
        default:
            BACKUP_TOK
            Factor();
            break;
    }
}

static void term()
/* Multiply and divide */
{
    int id;

    UFactor();
    NEXT_TOKEN
    id = token_name;

    while (id == MULTIPLY || id == DIVIDE) {
        UFactor();
        if (id == MULTIPLY)
            emit_multiply();
        else if (id == DIVIDE)
            emit_divide();

        NEXT_TOKEN
        id = token_name;
    }
}

static void aexpr()
/* Plus and minus */
{
    int id;

    term();

    while (token_name == PLUS || token_name == MINUS) {
        id = token_name; 
        term();

        if (id == PLUS)
            emit_plus();
        else if (id == MINUS)
            cont21ii(MINUS, 0);
    }
}

static void cexpr()
/* Concat expression
   X & Y */
{
    int concat_count = 0;

    aexpr();

    while (token_name == CONCAT) {
        aexpr();
        concat_count++;
    }

    if (concat_count == 1)
        cont21ii(CONCAT, 0);
    else if (concat_count > 1) {
        op_info1 = concat_count + 1;
        emit_concat_n();
    }
    /* Else concat_count is still 0, do nothing here. */
}

static void rexpr()
/* Relational expression
   <, >=, =, !=, <=, > */
{
    int id;

    cexpr();

    while (token_name <= GREATER && token_name >= LESS) {
        id = token_name;
        cexpr();
        cont21ii(id, 1);
    }
}

static void expr()
{
    int id, patch;

    id = -1;
    patch = 0;

    while (1) {
        if (id != -1 && id != XOR && short_circuit > 0) {
            if (id == OR)
                emit_sc1andor(SC1_OR);
            else
                emit_sc1andor(SC1_AND);
            patch = seg_pos + 1;
            emit_forward_addr();
            short_circuit_B = 1;
        }

        rexpr();

        if (id != -1) {
            if (id != XOR && short_circuit > 0) {
                if (token_name != THEN && token_name != DO) {
                    if (id == OR)
                        emit_sc2andor(SC2_OR);
                    else
                        emit_sc2andor(SC2_AND);
                }
                else {
                    SC1_type = id; /* if or while or elsif must patch. */
                    emit_sc2null();
                }
                BACKPATCH(patch, seg_pos + 1);
            }
            else
                cont21ii(id, 1);
        }

        id = token_name;
	if (id != OR && id != AND && id != XOR)
	    break;
    }

    BACKUP_TOK
    SC1_patch = patch;
}

static void type_check(int var)
{
    int which_type;

    which_type = symtab[var][S_VTYPE];

    if (OpTypeCheck && which_type != OBJECT_TYPE) {
        op_info1 = var;
        switch (which_type) {
            case INTEGER_TYPE:
                emit_integer_check();
                break;
            case SEQUENCE_TYPE:
                emit_sequence_check();
                break;
            case ATOM_TYPE:
                emit_atom_check();
                break;
            default:
                if (symtab[symtab[which_type][S_NEXT]][S_VTYPE] == INTEGER_TYPE)
                    emit_integer_check();

                cg_push(var);
                op_info1 = which_type;
                emit_proc();
                emit_type_check();
                break;
        }
    }

    if (!OpTypeCheck) {
        op_info1 = var;

        if (which_type == SEQUENCE_TYPE || 
             symtab[symtab[which_type][S_NEXT]][S_VTYPE] == SEQUENCE_TYPE)
            emit_sequence_check();
        if (which_type == INTEGER_TYPE ||
             symtab[symtab[which_type][S_NEXT]][S_VTYPE] == INTEGER_TYPE)
            emit_integer_check();
    }
}

static void assignment()
{
    int assign_op, dangerous, scope, slice, subs, subs1_patch;

    left_sym = token_sym;
    undefined_var(left_sym);

    scope = symtab[left_sym][S_SCOPE];

    if (scope == SC_LOOP_VAR || scope == SC_GLOOP_VAR)
        compile_error("May not assign to a for-loop variable.");

    if (symtab[left_sym][S_MODE] == M_CONSTANT)
        compile_error("May not change the value of a constant.");

    if (OpWarning) {
        if (symtab[left_sym][S_USAGE] == U_VAR_UNUSED)
            symtab[left_sym][S_USAGE] = U_VAR_WRITTEN;
        else if (symtab[left_sym][S_USAGE] == U_VAR_READ)
            symtab[left_sym][S_USAGE] = U_VAR_RW;
    }

    NEXT_TOKEN
    subs = 0;
    slice = 0;
    dangerous = 0;
    emit_opnd(left_sym);

    current_sequence_extra--; current_sequence_pos++;
    if (current_sequence_extra == -1) {
        current_sequence = (int *)realloc(current_sequence, (current_sequence_pos+32) *
                           sizeof(int));
        current_sequence_extra = 31;
    }

    current_sequence[current_sequence_pos] = left_sym;

    while (token_name == LEFT_SQUARE) {
        if (lhs_ptr) {
            current_sequence_extra++; current_sequence_pos--;
            if (subs == 1) {
                subs1_patch = seg_pos + 1;
                emit_lhs_subs(LHS_SUBS1); /* creates new current_sequence */
            }
            else
                emit_lhs_subs(LHS_SUBS); /* adds to current_sequence */
        }

        subs++;

        if (subs == 1)
            init_check(left_sym, 1);

        expr();
        NEXT_TOKEN

        if (token_name == SLICE) {
            expr();
            slice = 1;
            tok_match(RIGHT_SQUARE);
            NEXT_TOKEN

            break; /* no further subs or slices allowed */
        }
        else {
            BACKUP_TOK
            tok_match(RIGHT_SQUARE);
        }
        NEXT_TOKEN
        lhs_ptr = 1;
    }

    lhs_ptr = 0;

    assign_op = token_name;

    if (token_name != EQUALS && token_name <= PLUS_EQUALS && token_name >= CONCAT_EQUALS)
        compile_error("Syntax Error - Expected to see =, +=, -=, *=, /= or &=\n");

    if (!subs) {
        if (assign_op == EQUALS) {
            expr(); /* RHS expression */
            init_check(left_sym, 0);
        }
        else {
            init_check(left_sym, 1);

            if (OpWarning) {
                if (symtab[left_sym][S_USAGE] == U_VAR_UNUSED)
                    symtab[left_sym][S_USAGE] = U_VAR_READ;
                else if (symtab[left_sym][S_USAGE] == U_VAR_WRITTEN)
                    symtab[left_sym][S_USAGE] = U_VAR_RW;
            }

            emit_opnd(left_sym);
            expr(); /* RHS expression */
            emit_assign_op(assign_op);
        }

        emit_assign();
        type_check(left_sym);
    }
    else {
        factors = 0;
        lhs_subs_level = -1;

        /* RHS expression */
        expr();

        if (subs > 1) {
            if (factors == 1 && lhs_subs_level >= 0 && lhs_subs_level < subs+slice)
                dangerous = 1;

            if (dangerous)
                BACKPATCH(subs1_patch, LHS_SUBS1_COPY);
        }

        if (slice) {
            if (assign_op != EQUALS) {
                if (subs == 1)
                    emit_assign_op_slice(ASSIGN_OP_SLICE);
                else
                    emit_assign_op_slice(PASSIGN_OP_SLICE);
               emit_assign_op(assign_op);
            }
            if (subs == 1)
               emit_assign_slice(ASSIGN_SLICE);
            else
               emit_assign_slice(PASSIGN_SLICE);
        }
        else {
            if (assign_op == EQUALS) {
                if (subs == 1)
                    emit_assign_subs();
                else
                    emit_m3(PASSIGN_SUBS);
            }
            else {
                if (subs == 1)
                    emit_opsubs(ASSIGN_OP_SUBS);
                else
                    emit_opsubs(PASSIGN_OP_SUBS);
                emit_assign_op(assign_op);
                if (subs == 1)
                    emit_m3(ASSIGN_SUBS);
                else
                    emit_m3(PASSIGN_SUBS);
            }
        }

        if (subs > 1) {
            if (dangerous) {
                cg_push(left_sym);
                cg_push(lhs_subs1_copy_temp); /* will be freed */
                previous_op = -1;
                emit_assign();
            }
            else
                free_temp(lhs_subs1_copy_temp);
        }

        if (OpTypeCheck && symtab[left_sym][S_VTYPE] != SEQUENCE_TYPE)
            type_check(left_sym);
    }

    current_sequence_extra++; current_sequence_pos--;

    if (OpTrace) {
        emit(DISPLAY_VAR);
        emit(left_sym);
    }
}

static void return_statement()
{
    if (OpTrace) {
        emit(ERASE_PRIVATE_NAMES);
        emit(currentsub);
    }

    if (symtab[currentsub][S_TOKEN] != PROC) {
        expr();
        func_return = 1;
        emit_returnf();
    }
    else
        emit_returnp();

    BACKUP_NEXT_TOKEN

    not_reached(token_name, "return");
}

static void exit_statement()
{
    if (!loop_nest)
        compile_error("'exit' must be inside of a loop.");

    emit_m1(EXIT);
    appendXlist(seg_pos + 1);

    /* to be back-patched */
    emit_forward_addr();

    BACKUP_NEXT_TOKEN

    not_reached(token_name, "exit");
}

static void if_statement()
{
    int e_list_base, prev_false, prev_false2;

    e_list_base = e_list_pos;
    short_circuit++;
    short_circuit_B = 0;
    SC1_type = 0;
    expr();
    emit_ifwhile(IF);

    prev_false = seg_pos + 1;
    prev_false2 = 0;
    emit_forward_addr();

    if (SC1_type == OR) {
        BACKPATCH(SC1_patch - 3, SC1_OR_IF);
        BACKPATCH(SC1_patch, seg_pos + 1);
    }
    else if (SC1_type == AND) {
        BACKPATCH(SC1_patch - 3, SC1_AND_IF);
        prev_false2 = SC1_patch;
    }

    short_circuit--;
    tok_match(THEN);
    statement_list();
    NEXT_TOKEN

    while (token_name == ELSIF) {
        emit_m1(ELSE);
        appendElist(seg_pos + 1);
        emit_forward_addr();
        BACKPATCH(prev_false, seg_pos + 1);

        if (prev_false2)
            BACKPATCH(prev_false2, seg_pos + 1);

        start_source_line(1);
        short_circuit++;
        short_circuit_B = 0;
        SC1_type = 0;
        expr();
        emit_ifwhile(IF);

        prev_false = seg_pos + 1;
        prev_false2 = 0;
        emit_forward_addr();

        if (SC1_type == OR) {
            BACKPATCH(SC1_patch - 3, SC1_OR_IF);
            BACKPATCH(SC1_patch, seg_pos + 1);
        }
        else if (SC1_type == AND) {
            BACKPATCH(SC1_patch - 3, SC1_AND_IF);
            prev_false2 = SC1_patch;
        }
        short_circuit--;
        tok_match(THEN);
        statement_list();
        NEXT_TOKEN
    }

    if (token_name == ELSE) {
        start_source_line(0);
        emit_m1(ELSE);
        appendElist(seg_pos + 1);
        emit_forward_addr();
        BACKPATCH(prev_false, seg_pos + 1);

        if (prev_false2)
            BACKPATCH(prev_false2, seg_pos + 1);

        statement_list();
    }
    else {
        BACKUP_TOK
        BACKPATCH(prev_false, seg_pos + 1);

        if (prev_false2)
            BACKPATCH(prev_false2, seg_pos + 1);
    }

    tok_match(END);
    tok_match(IF);
    patchElist(e_list_base);
}

static void while_statement()
{
    int bp1, bp2, exit_base;

    bp1 = seg_pos + 1;
    short_circuit++;
    short_circuit_B = 0;
    SC1_type = 0;
    expr();
    tok_match(DO);
    optimized_while = 0;
    emit_ifwhile(WHILE);
    short_circuit--;
    if (!optimized_while) {
        bp2 = seg_pos + 1;
        emit_forward_addr(); /* will be patched */
    }
    else
        bp2 = 0;

    loop_nest++;
    exit_base = exit_list_pos;

    if (SC1_type == OR) {
        BACKPATCH(SC1_patch - 3, SC1_OR_IF);
        BACKPATCH(SC1_patch, seg_pos + 1);
    }
    else if (SC1_type == AND) {
        BACKPATCH(SC1_patch - 3, SC1_AND_IF);
        appendXlist(SC1_patch);
    }

    statement_list();
    tok_match(END);
    tok_match(WHILE);
    start_source_line(1);
    emit_m1(ENDWHILE);
    loop_nest--;
    emit(bp1);

    if (bp2)
        BACKPATCH(bp2, seg_pos + 1);

    patchXlist(exit_base);
}

static int set_private_scope(int sym, int type_sym)
{
    int entry, hashval;

    switch (symtab[sym][S_SCOPE]) {
        case SC_PRIVATE:
        case SC_LOOP_VAR:
            is_defined(sym);
            return sym;
            break;
        case SC_UNDEFINED:
        case SC_MULTIPLY_DEFINED:
            symtab[sym][S_SCOPE] = SC_PRIVATE;
            symtab[sym][S_VARNUM] = param_num;
            symtab[sym][S_VTYPE] = type_sym;
            return sym;
            break;
        case SC_LOCAL:
        case SC_GLOBAL:
        case SC_PREDEF:
            hashval = symtab[sym][S_HASHVAL];
            entry = new_entry(name_area[symtab[sym][S_NAME]], param_num, 
                     SC_PRIVATE, VARIABLE, hashval, buckets[hashval],
                     type_sym);
            buckets[hashval] = entry;
            return entry;
            break;
        default:
            internal_error("SetPS");
            return 0;
            break;
    }
}

static void for_statement()
{
    int bp1, def1, exit_base, loop_var_sym;

    NEXT_TOKEN

    if (token_name != VARIABLE && token_name != FUNC && token_name != TYPE && token_name != PROC)
        compile_error("Syntax Error - A loop variable name is expected here.\n");

    loop_var_sym = token_sym;
    tok_match(EQUALS);
    expr();
    tok_match(TO);
    loop_nest++;
    exit_base = exit_list_pos;
    expr();
    NEXT_TOKEN

    if (token_name == BY) {
        expr();
        def1 = 0;
    }
    else {
        emit_opnd(new_int_sym(1));
        BACKUP_TOK
        def1 = 1;
    }

    if (currentsub == toplevelsub) {
        is_defined(loop_var_sym);
        symtab[loop_var_sym][S_SCOPE] = SC_GLOOP_VAR;
        symtab[loop_var_sym][S_VTYPE] = OBJECT_TYPE;
    }
    else {
        loop_var_sym = set_private_scope(loop_var_sym, OBJECT_TYPE);
        param_num++;
        symtab[loop_var_sym][S_SCOPE] = SC_LOOP_VAR;
    }

    op_info1 = loop_var_sym;
    emit_for();
    emit(loop_var_sym);
    tok_match(DO);
    bp1 = seg_pos + 1;

    /* will be patched - don't straighten */
    emit(0);

    if (OpTrace) {
        emit(DISPLAY_VAR);
        emit(loop_var_sym);
    }

    statement_list();
    tok_match(END);
    tok_match(FOR);
    start_source_line(1);
    op_info1 = loop_var_sym;
    op_info2 = bp1 + 1;

    if (def1)
        emit_endfor(ENDFOR_INT_UP1); /* loop var might not be integer */
    else
        emit_endfor(ENDFOR_GENERAL); /* will be set at runtime by FOR op */

    BACKPATCH(bp1, seg_pos + 1);
    patchXlist(exit_base);
    loop_nest--;

    if (OpTrace) {
        emit(ERASE_SYMBOL);
        emit(loop_var_sym);
    }

    /* Hide the loop variable symbol. */
    hide(loop_var_sym);
}

static void global_declaration(int type_ptr, int is_global)
{
    int h, sym;

    while (1) {
        NEXT_TOKEN

        if (token_name != VARIABLE && token_name != FUNC && 
            token_name != PROC && token_name != TYPE) {
            compile_error("A name is expected here.\n");
        }

        sym = token_sym;
        is_defined(sym);

        if (symtab[sym][S_SCOPE] == SC_GLOBAL || symtab[sym][S_SCOPE] == SC_PREDEF) {
            h = symtab[sym][S_HASHVAL];
            sym = new_entry(name_area[symtab[sym][S_NAME]], 0, 0, VARIABLE, h, buckets[h], 0);
            buckets[h] = sym;
        }

        if (is_global)
            symtab[sym][S_SCOPE] = SC_GLOBAL;
        else
            symtab[sym][S_SCOPE] = SC_LOCAL;

        /* If type_ptr is 0, it's a constant. Anything else and it's just
           a normal variable. */
        if (!type_ptr) {
            symtab[sym][S_MODE] = M_CONSTANT;
            buckets[symtab[sym][S_HASHVAL]] = symtab[sym][S_SAMEHASH];
            tok_match(EQUALS);
            start_source_line(0);
            emit_opnd(sym);

            /* no new symbols can be defined in here */
            expr();

            buckets[symtab[sym][S_HASHVAL]] = sym;

            symtab[sym][S_USAGE] = U_VAR_WRITTEN;
            emit_assign();
        }
        else {
            symtab[sym][S_MODE] = M_NORMAL;
            symtab[sym][S_USAGE] = U_VAR_UNUSED;

            if (symtab[type_ptr][S_TOKEN] == OBJECT)
                symtab[sym][S_VTYPE] = OBJECT_TYPE;
            else
                symtab[sym][S_VTYPE] = type_ptr;
        }

        NEXT_TOKEN

        if (token_name != COMMA)
            break;
    }

    BACKUP_TOK
}

static void private_declaration(int type_sym)
{
    int sym;

    while (1) {
        NEXT_TOKEN

        if (token_name != VARIABLE && token_name != FUNC &&
            token_name != PROC && token_name != TYPE && token_name != NAMESPACE)
            compile_error("A variable name is expected here.");

        sym = set_private_scope(token_sym, type_sym);
        param_num++;
        NEXT_TOKEN
        symtab[sym][S_USAGE] = U_VAR_UNUSED;

        if (token_name != COMMA)
            break;
    }

    BACKUP_TOK
}

static void procedure_call()
{
    int opcode, sym;

    sym = token_sym;
    tok_match(LEFT_ROUND);

    parse_args(sym);

    if (symtab[sym][S_SCOPE] == SC_PREDEF) {
        opcode = symtab[sym][S_OPCODE];
        emit_op(opcode);

        if (opcode == ABORT) {
            BACKUP_NEXT_TOKEN

            not_reached(token_name, "abort()");
        }
    }
    else {
        /* Set the usage to reflect this routine being called.
           Only necessary if it's not a predefined routine. */
        symtab[sym][S_USAGE] = U_RT_CALLED;
        op_info1 = sym;
        emit_proc();
        if (OpTrace)
            emit(UPDATE_GLOBALS);
    }
}

static void print_statement()
{
    emit_opnd(new_int_sym(1));
    expr();
    emit_m2(QPRINT);
}

static void statement_list()
{
    stmt_nest++;

    while (1) {
        NEXT_TOKEN

        switch(token_name) {
            case VARIABLE:
                start_source_line(1);
                assignment();
                break;
            case PROC:
                start_source_line(1);
                procedure_call();
                break;
            case IF:
                start_source_line(1);
                if_statement();
                break;
            case FOR:
                start_source_line(1);
                for_statement();
                break;
            case WHILE:
                start_source_line(1);
                while_statement();
                break;
            case RETURN:
                start_source_line(1);
                return_statement();
                break;
            case EXIT:
                start_source_line(1);
                exit_statement();
                break;
            case QUESTION_MARK:
                start_source_line(1);
                print_statement();
                break;
            default:
                BACKUP_TOK
                stmt_nest--;
                init_delete();
                return;
                break;
        }
    }
}

static void sub_prog(int prog_type, int is_global)
{
    int h, i, p, pt, scope, sym, type_sym;

    leave_toplevel();

    NEXT_TOKEN

    if (token_name != VARIABLE && token_name != FUNC && token_name != PROC && token_name != TYPE)
        compile_error("A name is expected here.");

    p = token_sym;
    is_defined(p);

    if (prog_type == PROCEDURE)
        pt = PROC;
    else if (prog_type == FUNCTION)
        pt = FUNC;
    else
        pt = TYPE;

    scope = symtab[p][S_SCOPE];

    if (scope == SC_PREDEF || scope == SC_GLOBAL) {
        if (scope == SC_PREDEF) {
            sprintf(fe_buffer, "Warning : Built-in routine %s redefined.\n", name_area[symtab[p][S_NAME]]);
            add_warning(fe_buffer);
        }

        h = symtab[p][S_HASHVAL];
        sym = buckets[h];
        p = new_entry(name_area[symtab[p][S_NAME]], 0, 0, pt, h, sym, 0);
        buckets[h] = p;
    }

    currentsub = p;
    temps_allocated = 0;

    /* J.A. -> This expansion isn't that bad since realloc is used. */
    symtab[p] = (long *)realloc(symtab[p], ST_ROUTINE * sizeof(long));

    if (is_global)
        symtab[p][S_SCOPE] = SC_GLOBAL;
    else
        symtab[p][S_SCOPE] = SC_LOCAL;

    symtab[p][S_TOKEN] = pt;
    symtab[p][S_CODE] = code_area_pos;
    symtab[p][S_FIRSTLINE] = gline_number;
    symtab[p][S_TEMPS] = 0;

    start_source_line(0);
    tok_match(LEFT_ROUND);
    NEXT_TOKEN
    param_num = 0;

    while (token_name != RIGHT_ROUND) {
        if (token_name != TYPE) {
            if (token_name == VARIABLE)
                undefined_var(token_sym);

            compile_error("A type is expected here.");
        }

        type_sym = token_sym;
        NEXT_TOKEN

        if (token_name != VARIABLE && token_name != FUNC &&
            token_name != TYPE && token_name != PROC &&
            token_name != NAMESPACE) {
            compile_error("A parameter name is expected here.");
        }

        sym = set_private_scope(token_sym, type_sym);
        param_num++;

        if (OpWarning) {
            if (symtab[sym][S_USAGE] == U_VAR_UNUSED)
                symtab[sym][S_USAGE] = U_VAR_WRITTEN;
            else if (symtab[sym][S_USAGE] == U_VAR_READ)
                symtab[sym][S_USAGE] = U_VAR_RW;
        }

        NEXT_TOKEN

        if (token_name == COMMA) {
            NEXT_TOKEN
            if (token_name == RIGHT_ROUND)
                compile_error("Syntax Error - Expected to see a parameter declaration, not ')'.");
        }
        else if (token_name != RIGHT_ROUND)
            compile_error("Syntax Error - badly-formed list of parameters - expected ',' or ')'.");
    }

    symtab[p][S_NUM_ARGS] = param_num;

    if (symtab[p][S_TOKEN] == TYPE && param_num != 1)
        compile_error("Syntax Error - Types must have exactly one parameter.");

    NEXT_TOKEN

    while (token_name == TYPE) {
        private_declaration(token_sym);
        NEXT_TOKEN
    }

    sym = symtab[p][S_NEXT];
    /* Type check all the arguments */
    for (i = 1;i <= symtab[p][S_NUM_ARGS];i++) {
        type_check(sym);
        sym = symtab[sym][S_NEXT];
    }

    if (OpTrace) {
        emit(ERASE_PRIVATE_NAMES);
        emit(p);

        sym = symtab[p][S_NEXT];

        for (i = 1;i <= symtab[p][S_NUM_ARGS];i++) {
            emit(DISPLAY_VAR);
            emit(sym);
            sym = symtab[sym][S_NEXT];
        }

        emit(UPDATE_GLOBALS);
    }

    BACKUP_TOK

    func_return = 0;
    statement_list();
    tok_match(END);
    scope_exit();

    /* Make sure whatever keyword started this ends it. */
    tok_match(prog_type);

    if (prog_type != PROCEDURE) {
        if (!func_return) {
            if (prog_type == FUNCTION)
                compile_error("Syntax Error - No value returned from function.\n");
            else
                compile_error("Syntax Error - Type must return true/false value.\n");
        }
        /* This is emitted in case a function doesn't return. */
        /// OPTIMIZE : If loop_nest (and stmt_nest?) are both 0 and
        /// 'return' is declared, this shouldn't be needed. This is
        /// really only necessary when all returns are nested in multiple
        /// if/while/for blocks.
        emit_m1(BADRETURNF);
    }
    else {
        start_source_line(1);

        if (OpTrace) {
            emit(ERASE_PRIVATE_NAMES);
            emit(p);
        }
        emit_returnp();
    }

    symtab[p][S_STACK_SPACE] = temps_allocated + param_num;
    if (temps_allocated + param_num > max_stack_per_call) 
	max_stack_per_call = temps_allocated + param_num;

    straighten_branches();
    enter_toplevel();
}

static void set_with(int on_off)
{
    char *option;

    option = string_token();

    if (!strcmp(option, "warning")) {
        OpWarning = on_off;
        if (!OpWarning_called) {
            init_error();
            OpWarning_called = 1;
        }
    }
    else if (!strcmp(option, "trace"))
        OpTrace = on_off;
    else if (!strcmp(option, "type_check"))
        OpTypeCheck = on_off;
    else if (!strcmp(option, "profile")) {
        if (on_off) {
            if (AnyTimeProfile)
                compile_error("Can't mix profile and profile_time.");
            else {
                AnyStatementProfile = 1;
                OpProfileStatement = on_off;
            }
        }
    }
    else if (!strcmp(option, "profile_time")) {
        OpProfileTime = on_off;
        if (OpProfileTime) {
            if (AnyStatementProfile)
                compile_error("Can't mix profile and profile_time.");

            NEXT_TOKEN

            if (token_name == ATOM) {
                if (IS_ATOM_INT(symtab[token_sym][S_OBJ]))
                    sample_size = symtab[token_sym][S_OBJ];
                else
                    sample_size = -1;

                if (sample_size < 1 && OpProfileTime)
                    compile_error("Sample size must be an integer.");
            }
            else {
                BACKUP_TOK
                sample_size = 25000;
            }
        }
    }
    else
        compile_error("Unknown with/without option.");

    free(option);
}

void parser()
{
    while(1) {
        NEXT_TOKEN

        switch(token_name) {
            case VARIABLE:
                start_source_line(1);
                assignment();
                straighten_branches();
                break;
            case PROCEDURE:
            case FUNCTION:
            case TYPE_DECL:
                sub_prog(token_name, 0);
                break;
            case PROC:
                start_source_line(1);
                procedure_call();
                straighten_branches();
                break;
            case GLOBAL:
                NEXT_TOKEN

                if (token_name == PROCEDURE || token_name == FUNCTION || token_name == TYPE_DECL)
                    sub_prog(token_name, 1);
                else if (token_name == CONSTANT) {
                    global_declaration(0, 1);
                    straighten_branches();
                }
                else if (token_name == TYPE)
                    global_declaration(token_sym, 1);
                else {
                    if (token_name == VARIABLE)
                        undefined_var(token_sym);
                    else
                        compile_error("The 'global' keyword must be followed by a type.");
                }
                break;
            case CONSTANT:
                global_declaration(0, 0);
                straighten_branches();
                break;
            case IF:
                start_source_line(1);
                if_statement();
                straighten_branches();
                break;
            case FOR:
                start_source_line(1);
                for_statement();
                straighten_branches();
                break;
            case WHILE:
                start_source_line(1);
                while_statement();
                straighten_branches();
                break;
            case INCLUDE:
                new_include();
                break;
            case WITHOUT:
                set_with(0);
                break;
            case WITH:
                set_with(1);
                break;
            case TYPE:
                global_declaration(token_sym, 0);
                break;
            case QUESTION_MARK:
                start_source_line(1);
                print_statement();
                straighten_branches();
                break;
            case FUNC:
                compile_error("A function result must be assigned or used.");
                break;
            case RETURN:
                compile_error("'return' statement must be inside a procedure or function.");
                break;
            case EXIT:
                compile_error("'exit' statement must be inside a loop.");
                break;
            case ILLEGAL_CHAR:
                compile_error("Illegal character.");
                break;
            case GY_EOF:
                /* End of parsing. Finalize everything and return to main. */
                emit_m1(RETURNT);
                straighten_branches();

                code_area[0][0] = tls_pos-1;
                /* Set toplevelsub's size marker. */
                return;
                break;
            default:
                compile_error("Unknown command.");
                break;
        }
    }
}

